perm filename PARCPU.SAI[KA,SYS] blob sn#706004 filedate 1983-04-21 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00008 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	DEFINE
C00004 00003	in PASS2.SAI
C00007 00004
C00008 00005
C00011 00006
C00013 00007	PASS2.SAI
C00022 00008
C00027 ENDMK
C⊗;
DEFINE
	OLDMIC=[false], NEWMIC=[true], comment EARS/PRESS switch;
	VBPIMIC=[2540], HBPIMIC=[2540],

PARCODES = [
DEFINE
	ELShowCharactersShort = '0,
	ELSetSpaceXShort = '140,
	ELFont = '160,
	ELSetX = '356,
	ELSetY = '357,
	ELShowCharacters = '360,
	ELSetSpaceX = '364,
	ELResetSpace = '366,
	ELShowRectangle = '376,
	ELNop = '377,
	MEOL = -1,
	MICOUT(ARRY, COUNT) = [SOUT16(LISTCHAN, ARRY, COUNT)] ;
],

PARCARRAYS = [
	INTEGER PDIX, OUTCOUNT, TLIX, DLIX, DLREC, PDREC, DDREC;
	INTEGER dlgone, DLbeg, ELbeg, SpaceX, BrkToChange;
	INTEGER XPNeed, YPNeed, Pass2ScriptLevel, wordbreak;
	INTEGER DLBPRESET ; TES 11/17/74;
	INTEGER PressBug;
	INTEGER ARRAY TL[0:'4000], DL,PD[0:'2000], NILS[0:'400] ;
],

Comment in PASS2.SAI
	SOUT16 -- write a bunch of 16-bit words onto the output file.
	Words must be organized in low-order 16 bits of words in
	the array.  Keeps track of total number of words written
	in OUTCOUNT.

	MICPAD -- pads out file to next 256-word record, and
	returns record number of next record.

	WISHPMAP -- This function is provided rather than a
	PMAPped way to write a file.  It assumes that
	a number of 8-bit bytes have been deposited in
	a buffer in high core by IDPBing through DLBP.
	It moves these bytes
	into DL 16 bits at a time and calls SOUT16.
;
PARCOUT = [
	SIMPLE PROCEDURE SOUT16(INTEGER CHAN; INTEGER ARRAY LOC; INTEGER COUNT) ;
	BEGIN TES 4/20/75 ;
	OUTCOUNT←OUTCOUNT+COUNT;
	START!CODE
	PUSH '17,CHAN;
	PUSHJ '17,CVJFN;
	HRLI 2,'004400;
	HRR 2,LOC;
	subi 2,1;
	MOVN 3, COUNT;
	SOUT;
	END;
	END "SOUT16";

	SIMPLE INTEGER PROCEDURE MICPAD ;
	BEGIN
	INTEGER N ;
	N ← 256 - OUTCOUNT MOD 256 ;
	IF N < 0 THEN WARN("PUB BUG -- TOO MUCH IN A RECORD") ;
	IF N < 256 THEN MICOUT(NILS, N) ;
	IF OUTCOUNT MOD 256 THEN
		WARN("PUB BUG -- TOO LITTLE IN A RECORD") ;
	RETURN(OUTCOUNT DIV 256) ; COMMENT NO. OF NEXT RECORD ;
	END "MICPAD" ;

	SIMPLE PROCEDURE WISHPMAP ;
	BEGIN "WISHPMAP"
	INTEGER DLOC, SDP, COUNT ;
	DLOC ← LOCATION(DL[0]) ;
	SDP ← '042000677777 ;
	WHILE RH(SDP) < RH(DLBP) DO
		BEGIN
		COUNT ← 2 * (1 +
			(IF SDP LAND '777000 =
				(DLBP LAND '777000)-'1000
			   THEN DLBP LAND '777 ELSE '777)) ;
		START!CODE "WISH"
		LABEL LOOP ;
		MOVN '13,COUNT ;
		MOVE '14,DLOC ;
		HRL '14,'13 ;
		MOVE '13, SDP ;
	LOOP:	ILDB '15, '13 ;
		MOVEM '15, 0('14) ;
		AOBJN '14, LOOP ;
		MOVEM '13,SDP ;
		END "WISH" ;
		MICOUT(DL, COUNT) ;
		END ;
	END "WISHPMAP" ;

Comment Routines for dealing with the EL;

simple procedure ELByte (integer b);
	begin integer j;
		j←TLIX div 2;
		b←b land '377;
		TL[j]←(if (TLIX land 1)=0 then b lsh 8 else b+TL[j]);
		TLIX←TLIX+1;
	end;

simple procedure ELWord (integer b);
	begin ELByte(b lsh -8); ELByte(b) end;

simple procedure ELDWord (integer b);
	begin ELWord(b lsh -16); ELWord(b) end;

simple integer procedure ELPos;
	return (TLIX);

procedure ELOut;
	begin integer i,j;
	j←TLIX; if (j land 1)=1 then warn("EL bug");
	j←j div 2;
	MICOUT(TL, j);
	TLIX←0;
	end;


Comment Routines for putting things into the EL.;

simple procedure SetPosD(integer code,pos);
	begin
	if code=ELSetX then XPNeed←-1 else YPNeed←-1;
	ELByte(code);
	ELWord(pos);
	end;

simple procedure Show;
	if dlgone then begin
	if XPNeed neq -1 then SetPosD(ELSetX,XPNeed);
	if YPNeed neq -1 then SetPosD(ELSetY,YPNeed);
	while dlgone do begin
		integer i;
		i←dlgone min 255;
		if i leq 32 then ELByte(ELShowCharactersShort+i-1)
		  else begin
			ELByte(ELShowCharacters);
			ELByte(i);
		  end;
		dlgone←dlgone-i;
	end;
	end;

simple procedure SetPos(integer code,pos);
	begin
	Show; comment flush out existing characters;
	if code=ELSetX then XPNeed←pos else YPNeed←pos;
	end;

simple procedure SetSpace(integer s);
	begin
	Show;
	SpaceX←s;
	if s<2048 then ELWord((ELSetSpaceXShort lsh 8)+s) else
		begin
		ELByte(ELSetSpaceX);
		ELWord(s);
		end;
	end;

simple procedure BCPLString(string s; integer maxlen);
	begin integer i;
	ELByte(maxlen min length(s));
	for i←1 thru maxlen do
	  ELByte(if i>length(s) then 0 else s[i for 1]);
	end;

Comment The routine that computes how much to go up/down
	for super/sub scripts;

simple integer procedure SubSuperAmt(integer dir,rasthigh);
begin integer firstone,nlevel,dosuper,ix;
	nlevel←Pass2ScriptLevel+dir;
	firstone←(Pass2ScriptLevel=0) or (nlevel=0);
	dosuper←(Pass2ScriptLevel>0) or (nlevel>0);
	ix←(if firstone then 0 else 2)+(if dosuper then 0 else 4);
	Pass2ScriptLevel←nlevel;
Comment Value is a+b*high/1000, where a in micas;
	return(SCRIPTPARAMS[ix]+(SCRIPTPARAMS[ix+1]*rasthigh)%1000);
end;

],

Comment
	Body of INITIALAPPD(s) and APPD(s), the two basic routines
	that write out text characters.  This routine IDPB's chars
	into the output buffer, and accounts the widths as it does
	so.  Current X position is saved in CURRENTX, and
	is updated. CW  must point to an array of widths (micas).
;
PARCAPPD = [
	IF MICRO THEN TES 10/9/74 REVISED FOR CURRENTX ;
	BEGIN "MAPPD"
	INTEGER SRC,len,spcnt ;
	len←LENGTH(S);
	IF len=0 THEN RETURN(CHAR) ;
	if PressBug then Outstr(s);
	spcnt←0;
	QUICK!CODE "MAPPEND"
	LABEL LOOP ;
	DEFINE X=['13], BYTE=['14], CNT=['15];
		MOVEI CNT, S ;
		MOVE X, 0(CNT) ;
		MOVEM X, SRC ;
		HRRZ CNT,-1(CNT) ;
		MOVE X, CURRENTX ;
	LOOP:
		ILDB BYTE, SRC ;
		cain byte,SP;
		  aos spcnt;
		IDPB BYTE, DLBP ;
		ADD BYTE, CW ;
		SKIPLE 0(BYTE) ;
		ADD X, 0(BYTE) ; COMMENT ADD CHARACTER WIDTH ;
		SOJG CNT, LOOP ;
		MOVEM X, CURRENTX ;
	END "MAPPEND" ;
	DLBPRESET ← -1 ; TES 11/17/74;
	if spcnt neq 0 and wordbreak=false and SpaceX neq -1 then begin
		Show; comment put out chars not including these;
		ELByte(ELResetSpace);
		dlgone←dlgone+len;
		Show;
		SetSpace(SpaceX);
	end else dlgone←dlgone+len;
	RETURN(CHAR+len) ;
	END "MAPPD"

	ELSE
],

Comment PASS2.SAI
	Used to change fonts. Font number to switch to
	is in WHICH (mapped via FNDNUMBER to PRESS font).
;

PARCFONT = [
	IF MICRO THEN
		IF 0 LEQ WHICH LEQ 15 THEN
			BEGIN
			Show;
			ELByte(ELFont + FNTNUMBER[WHICH]) ;
			WHICH←FNTFIL[WHICH] ; MAKEBE(WHICH,CW) ; TES 10/9/74 ;
			END
		ELSE WARN("FONT NUMBER OUT OF RANGE")
	ELSE IF WHICH>9 THEN WARN("Font ignored")
	ELSE CTRL(6&(WHICH+"0"))
],

PARCLINE = [
	SIMPLE PROCEDURE MICTAB(INTEGER N) ;
		SetPos(ELSetx,CURRENTX←N+TLFTMAR) ;

	SIMPLE PROCEDURE OPENLINE(INTEGER FSTTAB, XFSTFONT) ;
	BEGIN "OPENLINE" TES 10/17/74 XFSTFONT ;
	dlgone←0; ELbeg←ELPos;
	DLbeg ← BYTECOUNT(DLBP, DLBP1) ;
	IF XFSTFONT<0 THEN CURRENTY ← LINEY ← BOTMAR + RASTPHIGH - LINE*RASTLHIGH ;
	IF XFSTFONT geq 0 then ELByte(ELFont+FNTNUMBER[XFSTFONT]);
	SetPos(ELSetY, CURRENTY);
	Pass2ScriptLevel←0; wordbreak←false;
	MICTAB(FSTTAB) ;
	BrkToChange←0; SpaceX←-1;
	if totbrks neq 0 and SHORTM > 0 then
		begin integer m;
		m←SHORTM div totbrks;
		n←SHORTM mod totbrks;
		if n neq 0 then begin
			m←m+1;
			BrkToChange←n;
		end;
		if PressBug then Outstr("=="&cvs(totbrks)&","&cvs(shortm)&","&cvs(m));
		SetSpace(m);
	end;	
	END "OPENLINE" ;

	SIMPLE PROCEDURE CLOSELINE ;
	    IF DLBPRESET=-1 THEN
		BEGIN "CLOSEL"
		IF FULSTR(SR) THEN BEGIN MICTAB(RGTMAR-TLFTMAR) ; APPD(SR) ; SR←NULL END ;
		Show;
		if (ELPos land 1)=1 then ELByte(ELNop);
		ELWord(0);
		ELDWord(DLbeg);
		ELDWord(BYTECOUNT(DLBP,DLBP1)-DLbeg);
		ELDWord(0); comment XeYe;
		ELWord(TLFTMAR); ELWord(LINEY-RASTLHIGH/3);
		ELWord(RGTMAR-TLFTMAR); ELWord(RASTLHIGH);
		ELWord(1+(ELPos-ELbeg) div 2);
		END "CLOSEL"
	    ELSE DLBP ← DLBPRESET ; TES 11/17/74;
],

PARCBAR = [
	begin integer x,i;
	x←0;
	for i←1 thru length(s) do x←x+CW[s[i for 1]];
	Show;
	SetPosD(ELSetX,CURRENTX);
	SetPosD(ELSetY,CURRENTY-80);
	ELByte(ELShowRectangle);
	ELWord(x); ELWord(20);
	SetPos(ELSetY,CURRENTY);
	APPD(s);
	end
],

PARCSUPER = [
	SetPos(ELSetY,(CURRENTY←CURRENTY+SubSuperAmt(1,RASTLHIGH)))
],

PARCSUB = [
	  SetPos(ELSetY,(CURRENTY←CURRENTY-SubSuperAmt(-1,RASTLHIGH)))
],

PARCRIGHT = [
		IF MICRO THEN
			BEGIN
			CURRENTX ← CURRENTX + F ; TES 10/9/74 ;
			SetPos(ELSetX, CURRENTX);
		END ELSE
],

PARCTAB = [
		ELSE IF F+TLFTMAR neq CURRENTX THEN
			SetPos(ELSetX,CURRENTX←F+TLFTMAR)
],

PARCONVERSION = [ TES REPLACED PARCPICHAR BY THIS FOR AUTOPACK ;
	BEGIN
	INTEGER NEWCOPYNUMBER, N ;
	N ← S[2 FOR 1] ;
	NEWCOPYNUMBER ← IF N=0 THEN 0 ELSE CVD(S[3 TO 2+N]) ;
	IF NEWCOPYNUMBER NEQ COPYNUMBER THEN
		BEGIN
		COPYNUMBER ← NEWCOPYNUMBER ;
Comment !!!!!! need something eventually !!!! ;
		END ;
	END
],

PARCLEFT = [
		SetPos(ELSetX,CURRENTX←CURRENTX - F*CHARW MAX 0)
],

PARCJUST = [
	begin "parcj" integer a,nx;
Comment F has desired mica spacing, using an exact computation.
	We will actually put out SpaceX, so record accordingly.  After
	a while, we decrease SpaceX to get line to come out exactly right;
	nx←CURRENTX←CURRENTX+F;
	if PressBug then Outstr("="&cvs(F)&","&cvs(SpaceX));
	if a geq 0 and (BRKS-1=totbrks or (a=1 and BRKS=totbrks div 2)) then
		SetPos(ELSetX, CURRENTX)
		else begin
			wordbreak←true; comment don't think space is quoted;
			APPD(SP);
			wordbreak←false;
		end;
	CURRENTX←nx; comment because APPD updates it;
	BrkToChange←BrkToChange-1;
	if BrkToChange=0 then SetSpace(SpaceX-1);
	end
],

PARCOVLY = [
	IF MICRO THEN
		BEGIN  integer tx ;
		K ← LDB(DLBP) ; COMMENT LAST CHARACTER OUTPUT ;
		IF K>'177 THEN
			WARN("ATTEMPT TO OVERLAY A DIRECTIVE")
		ELSE	BEGIN
			F ← LOP(SEG[G+1]) ;
			tx←CURRENTX;
			SetPos(ELSetX,tx-CW[K]);
			APPD(F);
			CURRENTX←tx;
			SetPos(ELSetX,CURRENTX);
			END ;
		END
	ELSE CTRL('10)
],

PARCLOSE = [
	IF MICRO THEN CLOSELINE ;
],

PARCPAGE = [
	IF MICRO THEN
	   IF ELPos = 0 THEN COMMENT BLANK PAGES ARE SUPPRESSED ;
	   ELSE BEGIN "PUTPD"
		APPD('0&'0);
		while (BYTECOUNT(DLBP,DLBP1) mod 4) neq 0 do APPD(0);
		WISHPMAP ; COMMENT WRITE OUT DL ;
		ELOut; comment write out EL;
		PD[PDIX] ← 0 ;
		PD[PDIX+1] ← DLREC ;
		dlgone←outcount mod 256;
		PD[PDIX+3] ← (if dlgone=0 then 0 else 256-dlgone);
		DLREC ← MICPAD ;
		PD[PDIX+2] ← DLREC-PD[PDIX+1] ;
		PDIX ← PDIX + 4 ;
		DLgone←0;
		END "PUTPD"
	ELSE
],

PARCDOC = [
	IF MICRO THEN
	BEGIN "FDTODD" integer f,logdir;
	for f←lofont thru hifont do if FULSTR(FNTNAME[f]) then
		begin string fam; integer pt,face;
		ELWord(16);
		ELWord(FNTNUMBER[f]);
		ELByte(0); ELByte(127);
		FONTTYPE(FNTNAME[f], fam, pt, face);
		BCPLString(fam, 19);
		ELByte(face); ELByte(0);
		ELWord(pt); ELWord(0);
	end;
	ELWord(0);
	ELOut;
	PDREC←MICPAD; Comment next record is part directory;
	PD[PDIX]←1;
	PD[PDIX+1]←DLREC;
	PD[PDIX+2]←PDREC-DLREC;
	PDIX←PDIX+4;
	MICOUT(PD,PDIX);
	DDREC←MICPAD;
	ELWord(27183);
	ELWord(DDREC+1);
	ELWord(PDIX div 4);
	ELWord(PDREC);
	ELWord(DDREC-PDREC);
	ELWord(-1);
	Comment Alto-format date in words 6,7. Algorithm courtesy
	E. Fiala: take lh of GTAD (days since 17 Nov 1858), subtract to
	get days since 1 Jan 1901, convert to seconds, and add in seconds
	in the current day (rh of GTAD);
	i←GTAD; ELDWord(((i lsh -18)-15385)*(3600*24)+(i land '777777));
	ELWord(1); ELWord(1); comment copy numbers;
	for i←10 thru '177 do ELWord(-1);
	BCPLString(LISTFILE, 51);
	GJINF(logdir,DUMMY,DUMMY);
	BCPLString(DIRST(logdir),31);
	BCPLString(ODTIM(-1,-1),37);
	ELOut;
	MICPAD;
	SFBSZ(LISTCHAN, 8) ;
	END "FDTODD" ;
],


Comment  Following functions in FONTS.SAI (passes 1 and 2) ;

PARCMIC = [
	IF ITS(PRESS) THEN DEVICE←MIC ELSE
],

PARCFONTTYPE = [
	begin "PFT" dcs 7/78;
	integer state,k; string m;
	m←n;
	state←0;
	mod←0; pt←0; fam←null;
	while length(m) do begin
		k←lop(m);
		if "a" leq k leq "z" then k←k-"a"+"A";
		if "0" leq k leq "9" then
			begin
			if state=0 then state←1
			end else begin
			if state=1 then state←2
			end;
		if state=0 then fam←fam&k;
		if state=1 then pt←pt*10+k-"0";
		if state=2 then begin
			if k="B" then mod←mod lor 2;
			if k="I" then mod←mod lor 1;
		end;
	end;
	if state=0 then Outstr("Illegal font spec. "&n&crlf);
	end "PFT";
],

PARCFILE = [
	begin "PF" dcs 7/78;
	integer i,w,t,bsiz,famno,pt,face,sl,len,ffn,bbc,siz,rota,pos,bc,ec,bpos;
	real scale; string fam,sn;
	for i←1 thru 127 do CW[i]←-1;
	FONTTYPE(nam, fam, pt, face);
	bsiz←-1; famno←-1;
	do begin "readix"
		w←bytein(chan);
		t←w lsh -12; len←(w land '7777)-1;
		if t=1 and famno=-1 then begin "famlook"
			famno←bytein(chan);
			for i←1 thru len-1 do begin
				w←bytein(chan);
				if i=1 then begin sl←(w div 256)-1; sn←w mod 256 end
				else begin
					if sl>0 then sn←sn&(w div 256);
					if sl>1 then sn←sn&(w mod 256);
					sl←sl-2;
				end;
			end;
			if not equ(sn,fam) then famno←-1;
			len←0;
		end;
		if t=4 then begin
			ffn←bytein(chan);
			bbc←bytein(chan);
			siz←bytein(chan);
			rota←bytein(chan);
			pos←bytein(chan)*(256*256); pos←pos+bytein(chan);
			i←bytein(chan); i←bytein(chan);
			len←0;

			if ffn=famno*256+face and rota=0 and
			  (abs(siz-((pt*2540) div 72))<2 or (bsiz=-1 and siz=0)) then begin
				bsiz←siz;
				bpos←pos;
				bc←bbc div 256; ec←bbc mod 256;
			end;
		end;
		for i←1 thru len do bytein(chan);
	end "readix" until t=0;

	if famno=-1 or bsiz=-1 then begin
		Outstr("Cannot find entry in Fonts.Widths for "&nam&crlf);
	end else begin "rdw"
		SFPTR(chan, bpos+3);
		scale←1.0;
		if bsiz=0 then scale←(2540*pt)/72000;
		FNTINF[WHICH]←bytein(chan)*scale;  comment char height;
		t←bytein(chan);
		if (t land '100000) then begin
			t←bytein(chan)*scale;
			for i←bc thru ec do CW[i]←t;
		end else begin
			for i←bc thru ec do begin
				t←bytein(chan);
				if t neq '100000 then CW[i]←t*scale;
			end;
		end;
		FNTNUMBER[WHICH]←-1;
	end "rdw";
	end "PF"
],

Comment in USERS.SAI ;

PARCASE = [
	CNVCASE["P"] ← CNVCASE["p"] ← MCASE ;
	CNVCASE["L"] ← CNVCASE["l"] ← PCASE ;
	CNVCASE["M"] ← CNVCASE["m"] ← 0
],

Comment in FILES.SAI;

PARCEXT = [
	(CASE ABS(DEVICE)-1 OF (".LPT",".TTY",".PRESS",".XGP"))
] ,

Comment in VARBL.SAI;

PARCMNEMONIC = [
	"PRESS"
] ;